{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.FlattenInheritance
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Flatten inheritance in Top syntax.
-- 
-- Precondition - traits already flattened.
--
-- NOTE - ** This does not inline super calls **
-- To inline super calls we need alpha renaming.
--
--------------------------------------------------------------------------------

module OchreLang.FlattenInheritance
  ( 
    flattenInheritance

  ) where

import OchreLang.CompilerMon
import OchreLang.SyntaxBase
import OchreLang.TopSyntax


import qualified Data.Map.Strict as Map

import Prelude hiding ( lookup )


-- | Instruments are /classes/.
--
type ClassDict = Map.Map Ident Instr

type MethodName = Ident
type MethodDefns = Map.Map MethodName MethodDefn


buildMethodDefns :: [MethodDecl] -> MethodDefns
buildMethodDefns = foldr fn Map.empty
  where
    fn (MethodDecl name body) = Map.insert name body

extractMethodDecls :: MethodDefns -> [MethodDecl]
extractMethodDecls = Map.foldrWithKey fn []
  where
    fn vid body ac = MethodDecl vid body : ac


buildClassDict :: [Instr] -> ClassDict
buildClassDict = foldr (\i ac -> Map.insert (instr_name i) i ac) Map.empty 

lookup :: Ident -> ClassDict -> Maybe Instr
lookup = Map.lookup

flattenInheritance :: Module -> Compiler Module
flattenInheritance modul@(Module { module_instrs = instrs }) = 
    let env = buildClassDict instrs in
    do { new_instrs <- mapM (flattenInstr env) instrs
       ; return $ modul { module_instrs = new_instrs }
       }



flattenInstr :: ClassDict -> Instr -> Compiler Instr
flattenInstr env ins@(Instr name super te ms) = case findSuper env ins of
    Nothing -> return ins
    Just super1 -> do { super2 <- flattenInstr env super1
                      ; let super_ms = instr_methods super2
                      ; let new_ms = mergeMethods ms super_ms 
                      ; return $ Instr { instr_name = name 
                                       , instr_superclass = super
                                       , instr_opt_trait = te
                                       , instr_methods = new_ms
                                       }
                      }


findSuper :: ClassDict -> Instr -> Maybe Instr
findSuper env (Instr { instr_superclass = super})   = 
    if super == (Ident "#none") then Nothing else lookup super env
    
-- | Rely on Map.union being left-biased...
mergeMethods :: [MethodDecl] -> [MethodDecl] -> [MethodDecl]
mergeMethods claz super = 
    extractMethodDecls $ Map.union (buildMethodDefns claz) 
                                   (buildMethodDefns super)